COMMENT ⊗   VALID 00015 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	 data trasnfer macros: SNDINT,SNDFP
C00004 00003	 data transfer : PUSHINTI,ARTVAL,RTVAL,AGTVAL,RTARR,FRVAL
C00015 00004		RTLEVS - returns leveloffset info of stack in integer buffer
C00017 00005		PAFFIX,PUNFIX
C00022 00006	 display: DISVT05
C00023 00007	 PSPROUT: used with COBEGIN
C00025 00008	 relative jumps: RFRCHK,RJMP,RJMPC
C00028 00009	 printing routines: RPRINT,PRVAL
C00032 00010	 supplementary motions: pmove,tadrive,tddrive,gather,rforce,setstf
C00036 00011	 supplementary functions: uparrow,dwnarrow,alpha,dollar,swap,vneg,vsmul,ftof
C00040 00012	 functions: sqrt,sin,cos,asin,acos,tan,atan2,log,exp
C00041 00013	 procedure handling: GTBLK
C00045 00014	 more stack ops: gtint,gvals,chngs
C00047 00015	 return from POINTY : pdone 
C00048 ENDMK
C⊗;
COMMENT ⊗ data trasnfer macros: SNDINT,SNDFP
	⊗

.MACRO	SNDINT X
	MOV  X,@INTPTR
	ADD  #2,INTPTR
	.ENDM

.MACRO	SNDFP X
	STF  X,@FPPTR
	ADD  #4,FPPTR
	.ENDM

.MACRO	SNDFIN X
	STCFI X,@INTPTR
	ADD   #2,INTPTR
	.ENDM
COMMENT	⊗ data transfer : PUSHINTI,ARTVAL,RTVAL,AGTVAL,RTARR,FRVAL
 routines to facilitate data transfer to POINTY interface
	XX is scalar index; Y is leveloffset of array element

	AGTVAL XX,Y	= PUSHINTI XX; GTVAL Y
	ACHNGE XX,Y	= PUSHINTI XX; CHNGE Y
	ARTVAL XX,Y	= AGTVAL XX,Y; RTVAL
	RTARR Y	 returns #elements and value of array offset Y
	RTVAL is used to transfer the top element of stack to the return buffer
	⊗;
PUSHINTI:
; The argument is an integer. Make a scalar out of it and
; push that scalar onto stack.

	FETCH R0
	LDCIF R0,AC0	;convert to real
	JSR PC,NOCMP
      	JSR PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF AC0,@(R3)	;Store result
	JSR PC,YESCMP
	CCC		;Clear condition code.
	RTS PC		;Done


AGTVAL:	JSR	PC,PUSHINTI	; get value of index to array
	JMP	GTVAL		; now get the offset of the array

CCHNGE:	CLR	R0
	JSR	PC,COPY0	; copy value of top element in stack
	JMP	CHNGE		; now do the assignment

CACHNG:	CLR	R0
	JSR	PC,COPY0	; copy value of top element in stack
ACHNGE:	JSR	PC,PUSHINTI	; get value of index to array
	JMP	CHNGE		; now update value of the array

CRTVAL:	MOV	(R3),R0		; return top of stack without popping
	JMP	RTVAL0

FRVAL:	FETCH	<R0>		; get offset
FRVAL0:	JSR	PC,GETARG	; R0←LOC[environment entry]
	BIT	#HDRTYP,(R0)	; check header exists
	BNE	1$		
	JSR	PC,MFRAME	; make frame header
1$:	MOV	2(R0),R0	; R0←LOC[frame header]
	PUSH	<R0>		; save R0
	ADD	#CALCS,R0	; R0←LOC[beginning of calculator list]
2$:	MOV	(R0),R0		; R0←LOC[next calcualtor to check]
	BEQ	6$		; Make sure there is something there
	BIT	#AFXTYP,TYPE(R0); Make sure it is an affixment
	BEQ	2$
	BIT	#FRAME2,TYPE(R0); Check if second frame in affixment
	BNE	2$		; If not, go check the next calculator
3$:	BIT	#EXPTRN,TYPE(R0); Is it an explicit trans?
	BEQ	4$
	MOV	@TRANS(R0),R0	; R0←LOC[trans]
	BR	5$
4$:	MOV	TRANS(R0),R0	; implicit trans
5$:	POP	<R1>		; get SP to correct state
	JMP	PC,RTVAL0	; retrun from RTVAL0
6$:	POP	<R0>
	JSR	PC,NOCMP
	CALL	GETVAL,<R0>	; R0←Value
	JSR	PC,YESCMP
	JMP	PC,RTVAL0	; return from RTVAL0
comment ⊗
RTARR:	FETCH	R0		; get offset of the array we are interested in
	PUSH	<R2>		; save R2
	JSR	PC,GETENV	; get environment pointer in R0
	MOV	2(R0),R2	; R2←LOC[array header]
	MOV	(R2)+,R0	; R0←# of dimensions of array
	CLR	-(SP)		; compute number of elements in array
1$:	MOV	(R2)+,R1	; R1←(ub[i]- lb[i])*mult[i]
	SUB	(R2)+,R1	;
	INC	R1		; add 1
	MUL	(R2)+,R1	;
	ADD	R1,(SP)		; and add it to elements so far
	SOB	R0,1$		; repeat for all the dimensions
	MOV	(SP)+,R1	; R1←# of elements in array
	SNDINT	R1		; send it back to 10
	PUSH	<R2>		; save current environment entry
	⊗;

RTARR:	JSR	PC,ARRSIZ	; get array size
				; R0←array size, R1←LOC[first env entry]
	SNDINT	R0
	PUSH	<R2>
	PUSH	<R1>		; (SP)←LOC[env entry]
	MOV	R0,R2		; R2←#elements
2$:	MOV	(SP),R0		; R0←LOC[env entry]
	ADD	#4,(SP)		; (SP)←next environment entry
	JSR	PC,GVAL1	; (R3)←LOC[value cell]
	JSR	PC,RTVAL	; return the element value
	SOB	R2,2$
	TST	(SP)+		; dont need the value of last push
	POP	<R2>		; get back the initial value of R2
	CCC
	RTS	PC		; and return

; following routine returns parameter values to the 10 and returns
; the following register values:
;	R0←#elements in the array
;	R1←LOC[env entry for first element]


RTPARS:	FETCH	R0		; get offset of the array we are interested in
	SNDINT	#XRTPARS	; send back info to 10
	SNDINT	R0		; send back arrayoffset number to 10
	PUSH	<R2>		; save R2
	PUSH	<INTPTR>	; save location of INTPTR for later use
	ADD	#2,INTPTR	; increment the value of intptr
	JSR	PC,GETENV	; get environment pointer in R0
	MOV	2(R0),R2	; R2←LOC[array header]
	MOV	(R2)+,R0	; R0←# of dimensions of array
	SNDINT	R0		; return # of dimensions
	CLR	-(SP)		; compute number of elements in array
1$:	MOV	(R2)+,R1	; R1←(ub[i]- lb[i])*mult[i]
	SNDINT	R1		; return upper bound
	SNDINT	(R2)		; return lower bound
	SUB	(R2)+,R1	;
	SNDINT	(R2)		; return multiplier
	INC	R1		; add 1
	MUL	(R2)+,R1	;
	ADD	R1,(SP)		; and add it to elements so far
	SOB	R0,1$		; repeat for all the dimensions
	MOV	(SP)+,R1	; R1←# of elements in array
	POP	<R0>
	MOV	R1,(R0)		; and send it to the buffer
	MOV	R1,R0		; R0←#of elements
	MOV	R2,R1		; R1←LOC[env entry of first element]
	POP	<R2>		; get back the initial value of R2
	CCC
	RTS	PC		; and return

ARRSIZ:	FETCH	R0		; takes array offset in R0 and returns
				; R0←#elements in array
				; R1←LOC[env entry of first element]
ARRSZ0::PUSH	<R2>
	JSR	PC,GETENV	; get environment pointer in R0
	MOV	2(R0),R2	; R2←LOC[array header]
	MOV	(R2)+,R0	; R0←#dimensions of array
	CLR	-(SP)		; compute # of elements in array
1$:	MOV	(R2)+,R1	; R1←(UB[i]-LB[i])*mult[i]
	SUB	(R2)+,R1
	INC	R1
	MUL	(R2)+,R1
	ADD	R1,(SP)
	SOB	R0,1$
	MOV	(SP)+,R0
	MOV	R2,R1
	POP	<R2>
	CCC
	RTS	PC

SC0:	MOV	#NILVEC,-(R3)
	JMP	SNEG
VT0:	MOV	#NILVEC,-(R3)
	JMP	VNEG
TR0:	PUSH	<R2>
	MOV	#NILTRN,-(R3)
	MOV	#NILVEC,-(R3)
	JSR	PC,VNEG
	JSR	PC,TMAKE
	POP	<R2>
	RTS	PC

ARRINI:	JSR	PC,RTPARS	; get the array size and LOC[env entry first]
	PUSH	<R2>
	MOV	R1,-(SP)	; (SP)←LOC[first env entry]
	MOV	R0,R2
	MOV	(SP),R0
	CMP	#SCLTYP,(R0)	; scalar array
	BNE	2$
	MOV	#SC0,1$
	BR	4$
2$:	CMP	#VECTYP,(R0)	;vector array
	BNE	3$
	MOV	#VT0,1$
	BR	4$
3$:	MOV	#TR0,1$		; niltrans
4$:	JSR	PC,@1$
	MOV	(SP),R0
	ADD	#4,(SP)
	JSR	PC,CHNG1
	SOB	R2,4$
	TST	(SP)+
	POP	<R2>
	CCC
	RTS	PC

DATA
1$:	0
CODE
ARTVAL:	JSR	PC,AGTVAL	; get the value of the array element
RTVAL:				; now output the value
	MOV	(R3)+,R0	; pop the top element  R0←loc[value cell]
RTVAL0:	MOV	#1,R1		; counter for counting number of elements
	CMPB	#TRNID,TAGID(R0)	;A trans?
	BEQ	1$
	CMPB	#VCTID,TAGID(R0)	;A vector?
	BEQ	2$
	BR	3$			;Must be a scalar
1$:	JSR	PC,EULER
	MOV	#EDAT,R0
	MOV	#4,R1
2$:	ADD	#2,R1

3$:	LDF	(R0)+,AC0		;load element into AC0
	STF	AC0,@FPPTR		;move it into return buffer
	ADD	#4,FPPTR		;update the pointer in the return buffer
	SOB	R1,3$			;get the next element
	RTS	PC

EULER:	MOV	#EDAT,R1
	JSR	PC,@LEULER	; now recorrect
	MOV	#EDAT+14,R1	; value of THETA
	LDF	(R1),AC0	; get value of O computed by euler in armcode
	SUBF	F90,AC0
	STF	AC0,(R1)+
	LDF	(R1),AC0	; PHI=A+90
	ADDF	F90,AC0
	STF	AC0,(R1)
	RTS	PC

DATA
F90:	.FLT2	90.0
F180:	.FLT2	180.0
EDAT:	.BLKW	30
YHAT:	.FLT2	0.0,1.0,0.0,1.0
ZHAT:	.FLT2	0.0,0.0,1.0,1.0
CODE
;	RTLEVS - returns leveloffset info of stack in integer buffer

RTLEVS:
COMMENT ⊗ Returns offset of top element in the stack if simple variable: if it is
	an array, returns the offset and the index sequentially.  This does not
	affect the stack. R0 and R1 are garbaged.
	⊗
	MOV R3,R1		;Use temporary stackpointer
	LDF @(R1)+,AC0		;Get value of top element of stack
	STCFI AC0,R0		;convert into integer and put in R0
	MOV R0,@INTPTR		;and store into integer buffer
	ADD #2,INTPTR		;and increment integer buffer pointer
	PUSH <R1>		;Since GETENV will clobber it
	JSR PC,GETENV		;Get the environment pointer in R0
	POP  <R1>		;TO recover R1
	BIT #ARYTYP,(R0)	;Do we have an array to access?
	BEQ 10$
	PUSH <R2>
	MOV 2(R0),R2		;R2 ← LOC[array header]
	MOV (R2)+,R0		;R0 ← # of dimensions of array
	POP  <R2>
3$:	LDF @(R1)+,AC0		;Get value of subscript
	STCFI AC0,@INTPTR	;Ship it into integer buffer
	ADD #2,INTPTR		;update the pointer
	SOB R0,3$		;Do all the subscripts
10$:	RTS PC			;Return with R0 and R1 garbaged
;	PAFFIX,PUNFIX

PAFFIX:
COMMENT ⊗ AFFIX together the two currently top elements
	and return their offsets in the integer buffer.
	⊗
	SNDINT #XAFFIX		;return affix code
	JSR PC,RTLEVS		;return the offset to the 10
	JSR PC,GTINT		;Get first frame offset
	JSR PC,GETARG		;R0 ← LOC[environment entry]
	BIT #HDRTYP,(R0)	;Test access type
	BNE 1$
	JSR PC,MFRAME		;If necessary make a new frame header
1$:	MOV 2(R0),R2		;R2 ← LOC[first frame header]
	JSR PC,RTLEVS		;return the offset to he 10
	JSR PC,GTINT		;Get second frame offset
	JSR PC,GETARG		;R0 ← LOC[environment entry]
	BIT #HDRTYP,(R0)	;Test access type
	BNE 2$
	JSR PC,MFRAME		;If necessary make a new frame header
2$:	MOV 2(R0),R1		;R1 ← LOC[second frame header]
	MOV @(R4),@INTPTR	;Get affixment code and return it
	ADD #2,INTPTR		;increment the integer pointer
	JMP AFFIX0		;jump into main affix routine and return from there

PUNFIX:
COMMENT ⊗ return the offsets of the two top elements on the
	stack and unfix them
	⊗
	MOV #2,4$
	SNDINT #XUNFIX		;return unfix code
	JSR PC,RTLEVS		;return offset to the 10
	JSR PC,GTINT		;Get first frame offset
	JSR PC,GETARG		;R0 ← LOC[environment entry]
	BIT #HDRTYP,(R0)	;Check header exists
	BEQ 1$			;  if not quit
	MOV 2(R0),R2		;R2 ← LOC[first frame header]
	DEC 4$
1$:	JSR PC,RTLEVS		;return offset of the second frame
	JSR PC,GTINT		;Get second frame offset
	JSR PC,GETARG		;R0 ← LOC[environment entry]
	BIT #HDRTYP,(R0)	;Check header exists
	BEQ 3$			;  if not quit
	MOV 2(R0),R1		;R1 ← LOC[second frame header]
	DEC 4$
2$:	BNE 3$
	JMP UNFIX0		; jump into main interpreter routine returning from there
3$:	RTS PC			; return from here

DATA
4$:	0
CODE
; display: DISVT05

DISVT05:
	FETCH <R0>
	TST R0			;R0=0 → display - R0=1 → nodisplay
	BNE 1$			;go to stop display
	MOVB #COFF+30,CURYXAL	;trick display routine to think we are at bottom
	MOV #1,FRMDDT		;forces display to update titles
1$:	MOV R0,DSPOK
	RTS PC
; PSPROUT: used with COBEGIN

PSPROUT:
	FETCH <R2>	;R1←# of statements
	MOV R2,R0
	ASH #1,R0
	INC R0
	JSR PC,GTFREE
	MOV R2,R1	; R1← # of interpreters to spawn
	PUSH <R0>	; save offset of new buffer	(1)
	PUSH <IPC(R4)>	;save current value of ipc	(2)
1$:	FETCH <R2>	;get the offset from beginning of sprout
	ASH #1,R2	;get byte offset
	ADD (SP),R2	;add the absolute address
	MOV R2,(R0)+	;stick it into new buffer
	FETCH <(R0)+>	;increment the zero - better be zero
	SOB R1,1$
	FETCH <(R0)+>	; increment one more term, better be zero
	TST (SP)+	; pop value of old ipc		(1)
	MOV IPC(R4),R1	; save current IPC value
	MOV (SP),IPC(R4); change ipc value to beginning of buffer
	PUSH <R1>	; and put old ipc value into the stack	(2)
	JSR PC,SPROUT	;jump into main AL routine
	POP <IPC(R4)>	;restore the ipc value		(1)
	POP <R0>	;R0←address of buffer		(0)
	JSR PC,RLFREE	;release the buffer
	CCC		;Clear condition code.
	RTS PC		;Done
; relative jumps: RFRCHK,RJMP,RJMPC
COMMENT ⊗ These routines are parallel to the jump and transfer of control
	routines in AL.  The relative jumps are needed to produce
	position independent pcode for the bodies of procedures
	⊗

RFRCHK:		; copied from FORCHK in INTRP.PAL
;Assume that the stack has, from surface in, the increment, the
;  final value, and the control variable's value, all of which are
;  scalar values.  If (FINAL-CONVAR)*(INCREMENT) ≥ 0 then this is a
;  no-op; otherwise, jump to the destination. 
;Arguments:  destination.	***** offset for control variable, destination *****
;******	MOV 4(R3),-(R3)	;Copy the control variable's value
;******	JSR PC,CHNGE	;Go update it
	LDF @2(R3),AC0	;AC0 ← final value
	SUBF @4(R3),AC0	;AC0 ← final - current
	MULF @(R3),AC0	;AC0 ← (final - current)*increment
	FETCH R0	;R0 ← destination offset ******** differs from FORCHK
	ASL R0		; to change to bytes
	CFCC
	BGE 1$		;Shall this be a no-op?
	BACKIPC		; since IPC is now pointing to next instruction
	ADD R0,IPC(R4)	;No; set new IPC. ******* in FORCHK this is MOV
;******	ADD #6,R3	;Pop the inc, final & control var off of the stack ****
1$:	CLR R0
	RTS PC		;Done

RJMP:
;Takes one argument: the relative offset of new address.
	MOV @IPC(R4),R0	; get the offset
	ASL R0		; change to bytes
	ADD R0,IPC(R4)	; increment IPC by the offset
	CCC		;Clear condition code.
	RTS PC		;Done

RJMPC:	;Parallel to JUMPC in INTERP.PAL[AL,HE]
	LDF	@(R3)+,AC0	;Get value of boolean
	CFCC			;copy condition codes
	BEQ	1$		;if false succeed - take branch
	BMPIPC			;skip over address
	RTS	PC		; & return
1$:	MOV	@IPC(R4),R0	; get the offset
	ASL	R0		; change to bytes
	ADD	R0,IPC(R4)	; branch
	RTS	PC		; & return

; printing routines: RPRINT,PRVAL

RPRINT:	MOV @IPC(R4),R0
	ASL R0
	ADD IPC(R4),R0	; put absolute address into R0 of string
	BMPIPC
	JMP PRINT0

TACK:
COMMENT ⊗ R1 = LOC[ascie string to tack on], R0 = LOC[where to put
it].  Returns R0 ← next location available in destination string.  ⊗
	MOVB (R1)+,(R0)+;Copy a byte
	BNE TACK	;Repeat while necessary
	DEC R0		;Go back past the null
	RTS PC		;Done

       .MACRO TACKST B	;tack the string B
	MOV #B,R1
	JSR PC,TACK
       .ENDM

       .MACRO TACKC B	;tack the character B
	MOVB #B,(R0)+	;move in the value
       .ENDM

; following routines are used to get a different form for printing
; R0 will point to next place in the string
PRVAL:	PUSH <R2>	;save R2
	EVWAIT CSLEVT
	MOV #4,R0	
	MOV #2,R1	; set format parameters to 2 dec places and squueze out blanks
	JSR PC,FORMAT	; use format to squeeze out blanks
	FETCH <R1>	; get type of printing
	ASH #1,R1	; TIMES 2
	MOV #OUTBUF,R0	; set R0←start of buffer
	JSR PC,@1$-2(R1); call appropriate routines to build up string
	CLRB (R0)	; ensure last character is a null to get rid of garbage
	MOV #OUTBUF,R0	; now print it
	JSR PC,TYPSTR
	JSR PC,RSTFOR	; restore format
	EVSIG CSLEVT
	POP <R2>	; restore r2
	CCC
	RTS PC
DATA
1$:	PRSCA
	PRVEC
	PRROT
	PRTRN
	PRFRM
CODE

PRSCA:	MOV (R3)+,R2	;R2←LOC[value cell]
PRREAL:	LDF (R2)+,AC0
	JSR PC,CVF	; go the conversion
	RTS PC

PRVEC:	MOV (R3)+,R2
PVECT:	TACKST VNAMEL	; tack "VECTOR("
	JSR PC,PRREAL	; tack first value
	TACKC COMMA
	JSR PC,PRREAL	; second value
	TACKC COMMA
	JSR PC,PRREAL	; third value
	TACKC ')	;")"
	RTS PC


PRROT:	PUSH <R0>
	MOV (R3)+,R0
	MOV #EDAT,R1
	JSR PC,EULER	; change to EULER angles
	MOV #EDAT,R2	; correct address for R2
	POP <R0>
PROT:	TACKST ROTZHC	; tack ROT(ZHAT,
	JSR PC,PRREAL	; value
	TACKC ')
	TACKC '*
	TACKST ROTYHC	; print ROT(YHAT,
	JSR PC,PRREAL
	TACKC ')
	TACKC '*
	TACKST ROTZHC	; print ROT(ZHAT,
	JSR PC,PRREAL
	TACKC ')
	RTS PC

PRTRN:	MOV #TNAMEL,R1	; print "TRANS("
	JMP PRFRM0

PRFRM:	MOV #FNAMEL,R1	; print "FRAME("
PRFRM0::JSR PC,TACK
	JSR PC,PRROT	; use common code with PRROT to compute euler angles
			; and tack the rot part
	TACKC COMMA	; output a comma
	JSR PC,PVECT	; print out the vector part
	TACKC ')	; print out right paren
	RTS PC


DATA
VNAMEL:  .ASCIZ /VECT(/
TNAMEL:: .ASCIZ /TR(/
FNAMEL:: .ASCIZ /FR(/
ROTZHC:: .ASCIZ /ROT(Z,/
ROTYHC:: .ASCIZ /ROT(Y,/
.EVEN
CODE
; supplementary motions: pmove,tadrive,tddrive,gather,rforce,setstf
RPMOVE:	MOV	LRPMOVE,R2	;set for position independent pcode
	JMP	MOVST2

RTADRIVE:			; absolute drive
	MOV	LRTADRIVE,R2
	JMP	MOVST2

RTDDRIVE:			; relative drive
	MOV	LRTDDRIVE,R2
	JMP	MOVST2

RCENTER:
	MOV	LRCENTER,R2
	JMP	MOVST2

MOVST2:	MOV	#XMOVE,@INTPTR	;code for move
	MOV	INTPTR,SVPTR	;save the current pointer
	ADD	#2,INTPTR	;increment pointer
	MOV	INTPTR,-(SP)	;save the pointer
	CLR	RPFLAG		;clear the retry flag
	JSR	PC,MOVSTA	;perform the motion
	TST	RPFLAG		;did we go through a retry?
	BNE	2$		;yes, we did
	CMP	INTPTR,(SP)+	;no, satisfactory move(check if move incremented
				;pointers
	BNE	1$		;yes, don't add anything
	CLR	@INTPTR		;no, clear next two words
	ADD	#2,INTPTR
	CLR	@INTPTR
	ADD	#2,INTPTR
1$:	RTS	PC		;return
2$:	MOV	SVPTR,INTPTR	;we went through a retry, back up
	TST	(SP)+		;pop the stack
	RTS	PC
DATA
SVPTR:	0			;used in case we do a RETRY$G
RPFLAG:	0			;checks if we did a RETRY$G
CODE

GATHER:	FETCH <R0>
	MOV  #FPPTR,R1	;address of FP buffer
	MOV  #INTPTR,R2	;address of INTEGER buffer
	JSR  PC,@LGATHER	; now go call the appropriate routine
	RTS  PC

RFORCE:	SNDINT #XRFORCE		;send back a xrforce
	MOV  #INTPTR,R1		;address of integer buffer
	JSR  PC,@LRFORCE
	CCC
	RTS PC

SETSTF:	MOV  (R3)+,-(SP)	; save trans address
	MOV  #1$+24.,R0		; address of arguments
	MOV  #6,R1		; six of them
2$:	LDF  @(R3)+,AC0		; get the argument
	STF  AC0,-(R0)		; put in the right place
	SOB  R1,2$
;	MOV  #1$,R0		; let R0 point to the right place
				; R0 will be pointing to the right place
	MOV  (SP)+,R1		; R1 has address of trans
	JSR  PC,@LSETSTF	; jump into the arm code
	CCC
	RTS  PC			; and return
DATA
1$:	.BLKW	12.		; space for 6 real numbers
CODE
; supplementary functions: uparrow,dwnarrow,alpha,dollar,swap,vneg,vsmul,ftof
UPARROW: MOV	#ZHAT,-(R3)	; ↑ z-axis pointing upward, current frame or trans
	MOV	2(R3),R0	; get original trans value
	LDF	(R0),AC0
	MULF	AC0,AC0		; (1,1)↑2
	LDF	4(R0),AC1
	MULF	AC1,AC1		; (2,1)↑2
	ADDF	AC1,AC0		; ACO←(1,1)↑2+(2,1)↑2
	CMPF	C0001,AC0	; If AC0<C001 skip ahead
	CFCC
	BGT	1$
	CLRF	AC0
	SUBF	10(R0),AC0	; -(3,1)
	JSR	PC,@LASIN	; take arc-sin
	BR	2$
1$:	LDF	34(R0),AC0
	LDF	30(R0),AC1
	JSR	PC,@LATAN2	; take arc-tan2( (2,3),(1,3))
2$:    	JSR	PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF	AC0,@(R3)	;Store result
	BR	DW3		;produce the rot

DOLLAR:	MOV	#NILROT,-(R3)	; $ station orientation, i.e. nilrot
	BR	DW2

ALPHA:	MOV	#ZHAT,-(R3)	; bgrasp orien at bpark, e.e. rot(zhat,180)
	BR	DW1

DWNARROW: MOV	#YHAT,-(R3)	; ↓ bpark orien, i.e. rot(yhat,180)
DW1:	MOV	#F180,-(R3)	; rot of 180 deg
DW3:	JSR	PC,VSAXWR	; return rot(vect,180) on stack
DW2:	JSR	PC,SWAP		; turn the top two elements around
	JSR	PC,TPOS		; take the position value of previous frame
	JSR	PC,TMAKE	; produce the transform
	RTS	PC		; and return

VNEG:	MOV	(R3),-(R3)	; copy the vector on the stack
	MOV	#NILVEC,2(R3)	; put in nilvector
	JMP	VSUB

VSMUL:	JSR	PC,SWAP		; reverse the two top elements
	JMP	SVMUL		; exit from SVMUL

SWAP:	MOV	(R3),-(SP)	; switch positions of top two elementsof stack
	MOV	2(R3),(R3)
	MOV	(SP)+,2(R3)
	RTS	PC

WRT:	JSR	PC,TORIEN	; v wrt t = orient(t)*v
VFREL:	JSR	PC,SWAP		; v rel f = t*v
	JMP	TVMUL

FTOF:	JSR	PC,SWAP		;t1→t2 = inv(t1)*t2
	JSR	PC,TINVRT
FFREL:	JSR	PC,SWAP		; f rel t = t*f
	JMP	TTMUL
				; take positions of three frames and put them
				; to the stack
FCONSTR: MOV	(R3)+,-(SP)	; save top two elements
	MOV	(R3)+,-(SP)
	JSR	PC,TPOS		; find position of frame 1
	MOV	(SP)+,-(R3)
	JSR	PC,TPOS		; find position of frame 2
	MOV	(SP)+,-(R3)
	JSR	PC,TPOS		; find position of frame 3
	JMP	CONSTR

; functions: sqrt,sin,cos,asin,acos,tan,atan2,log,exp
PSQRT:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,SQRT
	JMP	SRET

PSIN:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,SIN
	JMP	SRET

PCOS:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,COS
	JMP	SRET

PTAN:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,TAN
	JMP	SRET

PASIN:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,ASIN
	JMP	SRET

PACOS:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,ACOS
	JMP	SRET

PATAN2:	JSR	PC,SWAP
	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,ATAN2
	JMP	SRET

PLOG:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,LOG
	JMP	SRET

PEXP:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,EXP
	JMP	SRET

; procedure handling: GTBLK

GTBLK:
COMMENT ⊗
	 GTBLK n ..... q 
	n is size of the block of pcode to be copied
	 ..... is n words of information
	 the address of the block is to be put at the location of q + offset q
	⊗
	FETCH	<R0>		; get size of the block to get
	MOV	R0,R2		;
;	ADD	R0,R0		; get size in bytes
	JSR	PC,GTFREE	; get the size we need
	MOV	R0,-(SP)	; save the address of the block
1$:	FETCH	<R1>		; get word to transfer
	MOV	R1,(R0)+	; transfer to new area
	SOB	R2,1$
	MOV	@IPC(R4),R1	; now get the offset in which to stick the address of this block
	ASL	R1		; get it in bytes
	ADD	IPC(R4),R1	; get the absolute address
	BMPIPC
	MOV	(SP)+,(R1)	; write into the pcode ####### ... careful !
	RTS	PC		; and return

; more stack ops: gtint,gvals,chngs

APUSHOFFSET:
	JSR PC,PUSHINITI	; push index onto stack
PUSHOFFSET:
AREF:
; The argument is an integer. Make a scalar record and store the offset value
; on that stack.
; this routine is used in conjunction with GVALS and CHNGS
	JMP PUSHINTI

GTINT:	LDF	@(R3)+,AC0	;Get value of top element of stack
	STCFI	AC0,R0		;Convert it to integer & store it in R0
	RTS 	PC

GVALS:	JSR	PC,GTINT	; get the value of variable whose offset is on stack
	JMP	GVAL0

CHNGS:	JSR	PC,GTINT	; change the value of the variable whose offset is on stack
	JMP	CHNG0

DATA
HLTMSG:	0
CODE
; return from POINTY : pdone 

PDONE:
	MOV RF,SP		;Restore stack
	MOV -2(SP),RF		;RF ← old PC
	RTS RF			;Just return